home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Games of Daze
/
Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso
/
x2ftp
/
msdos
/
ai
/
fuzzy
/
avl.b
< prev
next >
Wrap
Text File
|
1986-11-29
|
16KB
|
502 lines
-------------------------------------------------------------------------------
-- --
-- Library Unit: AVL -- Generic AVL tree package --
-- --
-- Author: Bradley L. Richards --
-- --
-- Version Date Notes . . . --
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --
-- 1.0 12 Mar 86 Initial Version (delete & update not done) --
-- 1.1 19 Aug 86 Added update and release procedures --
-- 1.2 7 Sep 86 Added delete procedure; cleaned up code --
-- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - --
-- --
-- Library units used: none --
-- --
-- Description: This package provides generic functions for creating, --
-- modifying, and accessing AVL trees. AVL trees are binary trees --
-- which never have more than one level of imbalance between any --
-- two subtrees. Balance is maintained automatically when the tree --
-- is being built. --
-- The data to be maintained in the tree is never actually passed --
-- to this package. Rather, pointers to the data are passed in, via --
-- type "node_ptr." Also, comparison functions on the key fields of --
-- the data must be provided. The package requires a less-than and an --
-- equality test. --
-- --
-------------------------------------------------------------------------------
package body avl is
procedure add_node( tree : in out tree_ptr; data : in node_ptr;
duplicate : out boolean) is
needs_balanced : boolean;
pivot_parent, pivot, pivot_child, pivot_grandchild : tree_ptr := null;
procedure insert_node( tree : in out tree_ptr; data : in node_ptr;
duplicate, needs_balanced : out boolean;
pivot_parent, pivot, pivot_child,
pivot_grandchild : out tree_ptr ) is
found, pivot_found, placed : boolean := false;
ptr_child, ptr_grandchild : tree_ptr := null;
ptr : tree_ptr := tree;
begin
if tree = null then -- no nodes in tree
tree := new tree_node'(same, null, null, null, data);
duplicate := false;
needs_balanced := false;
else -- must search tree
loop
if equal(data, ptr.data) then
found := true;
elsif less_than(data, ptr.data) then
if ptr.left_child = null then
ptr.left_child := new tree_node'(same,null,null,ptr,data);
ptr_child := ptr.left_child;
placed := true;
else
ptr := ptr.left_child;
end if;
else
if ptr.right_child = null then
ptr.right_child := new tree_node'(same,null,null,ptr,data);
ptr_child := ptr.right_child;
placed := true;
else
ptr := ptr.right_child;
end if;
end if;
exit when found or placed;
end loop;
if found then
duplicate := true;
else -- trace back through the tree adjusting balances
duplicate := false;
loop
case ptr.balance is
when left => if ptr_child = ptr.left_child then
ptr.balance := tall_left;
else
ptr.balance := same;
end if;
pivot_found := true;
when same => if ptr_child = ptr.left_child then
ptr.balance := left;
else
ptr.balance := right;
end if;
ptr_grandchild := ptr_child;
ptr_child := ptr;
ptr := ptr.parent;
when right => if ptr_child = ptr.left_child then
ptr.balance := same;
else
ptr.balance := tall_right;
end if;
pivot_found := true;
when others => -- some sort of major tree construction
-- error has occurred
raise avl_error;
end case;
exit when pivot_found or (ptr = null);
end loop;
needs_balanced := false;
if pivot_found then
if (ptr.balance = tall_left) or (ptr.balance = tall_right) then
needs_balanced := true;
pivot_parent := ptr.parent;
pivot := ptr;
pivot_child := ptr_child;
pivot_grandchild := ptr_grandchild;
end if;
end if;
end if;
end if;
end insert_node;
begin -- add node
--
-- insert_node places the node into the tree, adjusts all
-- required balances, and determines whether or not the
-- tree needs balanced. If it does, pivot points to the
-- pivot node for the rotation(s)
--
insert_node(tree, data, duplicate, needs_balanced, pivot_parent,
pivot, pivot_child, pivot_grandchild);
if needs_balanced then
if needs_single_rotation(pivot_parent, pivot, pivot_child,
pivot_grandchild) then
rotate_singly(pivot_parent, pivot, pivot_child);
else
rotate_doubly(pivot_parent, pivot, pivot_child, pivot_grandchild);
end if;
if pivot_parent = null then -- pivot points to new root node
tree := pivot;
end if;
end if;
end add_node;
function copy_tree( original : tree_ptr ) return tree_ptr is
root : tree_ptr;
begin
if original = null then
return null;
else
root := new tree_node;
root.balance := original.balance;
root.data := original.data;
root.left_child := copy_tree(original.left_child);
root.right_child := copy_tree(original.right_child);
end if;
end copy_tree;
--
-- Delete_node -- This routine, when implemented, will remove the matching
-- node from the AVL structure and automatically rebalance
-- the tree. It should also allow an option to deallocate
-- the data.
--
procedure delete_node( tree : in out tree_ptr; data : in node_ptr;
not_found : out boolean) is
duplicate : boolean;
new_tree, parent, ptr : tree_ptr;
--
-- Merge merges two trees together. The right tree is assumed to be
-- either the smaller tree (for efficiency) or perhaps an invalid
-- AVL tree.
--
procedure merge( t1, t2 : tree_ptr; new_tree : out tree_ptr ) is
tree : tree_ptr := t1; -- t1 is the working AVL tree
ptr : tree_ptr := t2;
parent : tree_ptr;
begin
if tree /= null then
tree.parent := null;
end if;
if ptr /= null then
ptr.parent := null;
end if;
while ptr /= null loop
if ptr.left_child /= null then
ptr := ptr.left_child;
elsif ptr.right_child /= null then
ptr := ptr.right_child;
else -- both children null
add_node(tree, ptr.data, duplicate);
if duplicate then
raise avl_error;
end if;
parent := ptr.parent;
if parent /= null then
if parent.left_child = ptr then
free_AVL(parent.left_child);
else
free_AVL(parent.right_child);
end if;
else
free_AVL(ptr);
end if;
ptr := parent;
end if;
end loop;
new_tree := tree;
end merge;
begin -- delete_node
if tree = null then
not_found := true;
else
ptr := fetch_node(tree, data);
if ptr = null then
not_found := true;
else
if ptr.balance = right then -- list taller tree first
merge(ptr.right_child, ptr.left_child, new_tree);
else
merge(ptr.left_child, ptr.right_child, new_tree);
end if;
parent := ptr.parent;
if parent /= null then -- didn't delete the root node
if parent.left_child = ptr then
parent.left_child := null;
else
parent.right_child := null;
end if;
merge(new_tree, tree, new_tree);
end if;
free_AVL(ptr);
tree := new_tree;
end if;
end if;
end delete_node;
--
-- Fetch_node -- This function returns a pointer to the data associated
-- with the AVL node which matches the input data key field.
--
function fetch_node( tree : tree_ptr; data : node_ptr) return node_ptr is
node : tree_ptr;
begin
node := fetch_node(tree, data);
if node = null then
return null;
else
return node.data;
end if;
end fetch_node;
function fetch_node( tree : tree_ptr; data : node_ptr) return tree_ptr is
ptr : tree_ptr := tree;
begin
if tree = null then
return null;
else
loop
if equal(data, ptr.data) then
return ptr;
elsif less_than(data, ptr.data) then
if ptr.left_child = null then
return null;
else
ptr := ptr.left_child;
end if;
else
if ptr.right_child = null then
return null;
else
ptr := ptr.right_child;
end if;
end if;
end loop;
end if;
end fetch_node;
function init_tree return tree_ptr is
begin
return null;
end init_tree;
function needs_single_rotation(p1, p2, p3, p4 : in tree_ptr) return boolean is
begin
if p4 /= null then
if ( (p3.balance = left) and (p2.balance = tall_right) ) or
( (p3.balance = right) and (p2.balance = tall_left) ) then
return false; -- requires double rotation
else
return true;
end if;
else -- we shouldn't have been called
raise avl_error;
end if;
end needs_single_rotation;
--procedure print_tree( tree : tree_ptr ) is -- debug
--procedure print_node( node : tree_ptr; indent : natural ) is
--procedure space( num : natural ) is
--begin
--for i in 1..num loop
--put(' ');
--end loop;
--end space;
--begin
--space(indent);
--if node = null then
--put_line("<null>");
--else
--put_data(node.data);
--put(" ");
--put(node.balance);
--if (node.left_child /= null) and then
--(node.left_child.parent /= node) then
--put(" left child parent discrepancy");
--end if;
--if (node.right_child /= null) and then
--(node.right_child.parent /= node) then
--put(" right child parent discrepancy");
--end if;
--new_line;
--print_node(node.left_child, indent+2);
--print_node(node.right_child, indent+2);
--end if;
--end print_node;
--begin
--if (tree /= null) and then (tree.parent /= null) then
--put_line("tree parent discrepancy");
--end if;
--print_node(tree, 0);
--end print_tree;
--
-- Release -- This routine releases all nodes in an AVL tree. It does
-- not release the data associated with the nodes. For cases
-- where the AVL structure was just a temporary way of
-- structuring the data this is fine, but eventually the
-- release procedure should allow an option to release data
-- associated with AVL nodes. This will require another
-- generic procedure parameter to the package.
--
procedure release( tree : in out tree_ptr ) is
begin
if tree /= null then
if tree.left_child /= null then
release( tree.left_child );
end if;
if tree.right_child /= null then
release( tree.right_child );
end if;
free_AVL(tree);
end if;
end release;
procedure rotate_doubly(p1, p2, p3, p4 : in out tree_ptr) is
begin
if p2.balance = tall_left then
p2.left_child := p4.right_child;
if p4.right_child /= null then
p4.right_child.parent := p2;
end if;
p3.right_child := p4.left_child;
if p4.left_child /= null then
p4.left_child.parent := p3;
end if;
p4.left_child := p3;
p4.right_child := p2;
case p4.balance is
when left => p2.balance := right;
p3.balance := same;
when same => p2.balance := same;
p3.balance := same;
when right => p2.balance := same;
p3.balance := left;
when others => raise avl_error;
end case;
else
p2.right_child := p4.left_child;
if p4.left_child /= null then
p4.left_child.parent := p2;
end if;
p3.left_child := p4.right_child;
if p4.right_child /= null then
p4.right_child.parent := p3;
end if;
p4.left_child := p2;
p4.right_child := p3;
case p4.balance is
when left => p3.balance := right;
p2.balance := same;
when same => p3.balance := same;
p2.balance := same;
when right => p3.balance := same;
p2.balance := left;
when others => raise avl_error;
end case;
end if;
p4.parent := p1;
p4.balance := same;
p2.parent := p4;
p3.parent := p4;
if p1 = null then
p2 := p4; -- we've changed the root
elsif p1.left_child = p2 then
p1.left_child := p4;
else
p1.right_child := p4;
end if;
end rotate_doubly;
procedure rotate_singly(p1, p2, p3 : in out tree_ptr) is
begin
if p2.balance = tall_left then
p2.left_child := p3.right_child;
if p3.right_child /= null then
p3.right_child.parent := p2;
end if;
p3.right_child := p2;
if p3.balance = left then
p2.balance := same;
else
p2.balance := left;
end if;
else
p2.right_child := p3.left_child;
if p3.left_child /= null then
p3.left_child.parent := p2;
end if;
p3.left_child := p2;
if p3.balance = right then
p2.balance := same;
else
p2.balance := right;
end if;
end if;
p2.parent := p3;
p3.balance := same;
p3.parent := p1;
if p1 = null then
p2 := p3; -- we've changed the root
elsif p1.left_child = p2 then
p1.left_child := p3;
else
p1.right_child := p3;
end if;
end rotate_singly;
--
-- Update_node -- This routine locates the node whose key field matches
-- the data and replaces the node data witht the new data
-- included in this call. If no matching node is found
-- not_found will be true.
--
-- This routine should be modified to optionally release
-- the old data.
--
procedure update_node( tree : in tree_ptr; data : in node_ptr;
not_found : out boolean ) is
ptr : tree_ptr := tree;
begin
if tree = null then
not_found := true;
else
loop
if equal(data, ptr.data) then
not_found := false;
ptr.data := data;
exit;
elsif less_than(data, ptr.data) then
if ptr.left_child = null then
not_found := true;
exit;
else
ptr := ptr.left_child;
end if;
else
if ptr.right_child = null then
not_found := true;
exit;
else
ptr := ptr.right_child;
end if;
end if;
end loop;
end if;
end update_node;
end avl;
